home *** CD-ROM | disk | FTP | other *** search
/ Shareware Overload Trio 2 / Shareware Overload Trio Volume 2 (Chestnut CD-ROM).ISO / dir40 / pc37042.zip / CBL / TEST370.ALC < prev    next >
Text File  |  1987-11-20  |  2KB  |  82 lines
  1.     TITLE 'TEST CALL TO PC/370 SUBROUTINE FROM MICRO FOCUS COBOL'
  2. * PGM-ID. TEST370.ALC
  3. * AUTHOR. DON HIGGINS.
  4. * DATE.   08/29/87.
  5. * REMARKS.
  6. *
  7. *           THIS SPECIFIC PROGRAM VERIFIES THE FOLLOWING ARGUMENTS
  8. *           PASSED FROM CALL370.CBL WORKING STORAGE AS FOLLOWS:
  9. *
  10. *             01 D-DATE PIC 9(6)               VALUE 082987.
  11. *             01 X-DATE PIC X(6)               VALUE '082987'.
  12. *             01 P-DATE PIC 9(15) USAGE COMP-3 VALUE 082987.
  13. *             01 C-DATE PIC 9(8)  USAGE COMP   VALUE 082987.
  14. *
  15. *           CALL "TEST370" USING D-DATE X-DATE P-DATE C-DATE.
  16. *
  17. *           AT ENTRY TO TEST370 THE 370 REGISTERS ARE SET AS FOLLOWS:
  18. *
  19. *             R1 = ADDRESS OF ADDRESS LIST WITH HIGH BIT SET IN LAST
  20. *                  WORD OF LIST.
  21. *
  22. *             R13 = STANDARD SAVE AREA
  23. *             R14 = RETURN ADDRESS
  24. *             R15 = ENTRY  ADDRESS
  25. *
  26. * MAINTENANCE.
  27. *
  28. * 11/20/87 DSH CLEAR R15 COBOL RETURN CODE AT EXIT
  29. *
  30. TEST370  CSECT
  31.     USING *,R15
  32.     LM    R3,R6,0(R1)
  33.     LA    R2,=C'HELLO FROM TEST370$'
  34.     SVC   WTO
  35.     LTR   R6,R6
  36.     BNM   ERR5               MISSING ENDING HIGH BIT
  37.     CLC   0(6,R3),=C'082987' CHECK EBCDIC D-DATE.
  38.     BNE   ERR1
  39.     CLC   0(6,R4),=C'082987' CHECK EBCDIC X-DATE.
  40.     BNE   ERR2
  41.     CP    0(8,R5),=P'082987' CHECK PACKED DATE
  42.     BNE   ERR3
  43.     CLC   0(4,R6),=F'082987' BINARY DATE
  44.     BNE   ERR4
  45.     LA    R2,=C'ALL DATA FIELD TESTS SUCCESSFUL!$'
  46.     SVC   WTO
  47.     XR    R15,R15
  48.     BR    R14
  49. ERR1     LA    R2,=C'D-DATE ERROR$'
  50.     SVC   WTO
  51.     SVC   TRACE
  52.     DC    C'BUG '
  53.     LA    R15,1
  54.     BR    R14
  55. ERR2     LA    R2,=C'X-DATE ERROR$'
  56.     SVC   WTO
  57.     SVC   TRACE
  58.     DC    C'BUG '
  59.     LA    R15,2
  60.     BR    R14
  61. ERR3     LA    R2,=C'P-DATE ERROR$'
  62.     SVC   WTO
  63.     SVC   TRACE
  64.     DC    C'BUG '
  65.     LA    R15,3
  66.     BR    R14
  67. ERR4     LA    R2,=C'C-DATE ERROR$'
  68.     SVC   WTO
  69.     SVC   TRACE
  70.     DC    C'BUG '
  71.     LA    R15,4
  72.     BR    R14
  73. ERR5     LA    R2,=C'MISSING END OF ADDRESS LIST BIT ERROR$'
  74.     SVC   WTO
  75.     SVC   TRACE
  76.     DC    C'BUG '
  77.     LA    R15,5
  78.     BR    R14
  79.     COPY  CPY\EQUREGS
  80.     COPY  CPY\EQUSVCS
  81.     END
  82.